<%
Function UrlEncode(Url_Str)
	If IsNull(Url_Str) Or Url_Str="" Then 
		UrlEncode = ""		
	Else
		UrlEncode = Server.URLEncode(Url_Str)
	End If
End Function

Function iif(ByVal val1,ByVal val2, ByVal val3)
	If CStr(val1)=CStr(val2) Then 
		val1 = val3
	End If
	iif = val1
End Function 


'去除内容中的HTML代码

Function stripHTML(strHTML)

	If strHTML="" Or IsNull(strHTML) Then 
		stripHTML = "" 
		Exit Function
	End If 

	'Strips the HTML tags from strHTML
	Dim objRegExp, strOutput
	Set objRegExp = New Regexp
	objRegExp.IgnoreCase = True
	objRegExp.Global = True
	objRegExp.Pattern = "<.+?>"
	'Replace all HTML tag matches with the empty string
	strOutput = objRegExp.Replace(strHTML, "")
	'Replace all < and > with < and >
	strOutput = Replace(strOutput, "<", "<")
	strOutput = Replace(strOutput, ">", ">")
	stripHTML = strOutput 'Return the value of strOutput
	Set objRegExp = Nothing

End Function


'正则表表达式验证函数 patrn-正则表达式　strng-需要验证的字符串 
'===============================================================
'patrn = "[\u4e00-\u9fa5A-Za-z0-9-_]+$" '中文 a-z0-9 _-字符
'strng="黄垂明@3_2007-11-9"
'Response.write RegExpTest(patrn,strng)

Function RegExpTest(patrn, strng)
	Dim regEx, retVal ' 建立变量。
	Set regEx = New RegExp ' 建立正则表达式。
	regEx.Pattern = patrn ' 设置模式。
	regEx.IgnoreCase = False ' 设置是否区分大小写。
	retVal = regEx.Test(strng) ' 执行搜索测试。
	RegExpTest = retVal
End Function


Sub CheckPriv()

	MenuPath = Request.ServerVariables("SCRIPT_NAME")

	If Session("Admin_SuperUser")="1" Then 
		Exit Sub 
	End If
	sql = "SELECT MenuID FROM uvw_Menu_Priv WHERE ParentID >0 AND MenuPath='" &MenuPath&"' AND Admin_UserID = "&Session("Admin_UserId")
	'writebr sql
	'endd

	Array_List = GetRsRows(Sql)
	If IsArray(Array_List)=False Then 
		AlertBox "你没有权限访问该页面","javascript:history.go(-1)"	
	End if	


End Sub



'检查指定表的某个字段的值是否存在

'Table_Name,Field_Name,Field_Type,Field_Value,Tips
'表名,		字段名,		字段类型 1字符、0 数字, 值,提示内容


Sub DenyIfRecordExist(Table_Name,Field_Name,Field_Type,Field_Value,Tips)

	If Field_Type="1" Then
		sqlTemp = "SELECT "& Field_Name &" FROM " & Table_Name & " WHERE " & Field_Name & "='"&Field_Value&"'"
	Else
		sqlTemp = "SELECT "& Field_Name &" FROM " & Table_Name & " WHERE " & Field_Name & "="&Field_Value
	End If

	Set rsTemp = conn.execute(sqlTemp)

	If Not rsTemp.Eof Then

		Set rsTemp = Nothing 
		AlertBox Tips,"javascript:history.go(-1)"

	End If

	Set rsTemp = Nothing 

End Sub


'检查是否为日期
Sub Check_IsDate(ByVal Check_Value)
	If Not IsDate(Check_Value)  Then
		AlertBox "参数错误,只能是日期类型!","javascript:history.go(-1)"
	End If
End Sub 
Sub Check_IsDate_Msg(ByVal Check_Value,Msg)
	If Not IsDate(Check_Value)  Then
		AlertBox Msg&"类型错误,只能是日期类型!","javascript:history.go(-1)"
	End If
End Sub 
Sub IsBehindDate(Begin_Date,End_Date)
	If IsDate(Begin_Date) And IsDate(End_Date) Then 
		day_number =  DateDiff("d",Begin_Date,End_Date)
		If day_number<1 Then 
			AlertBox "时间间隔不能小于1天!","javascript:history.go(-1)"	
		End If
	Else
		AlertBox "请检查的日期不是标准的日期格式!","javascript:history.go(-1)"
	End If
End Sub
'检查是否为数字
Sub Check_IsNumeric(Check_Value)
	If Not IsNumeric(Check_Value) Or check_value="" Then
		'Response.Write Check_Value
		AlertBox "参数错误!","javascript:history.go(-1)"
	End If
End Sub 

'禁止从外部提交数据
Sub Deny_OutSiteSubit()
	server_v1=Cstr(Request.ServerVariables("HTTP_REFERER"))
	server_v2=Cstr(Request.ServerVariables("SERVER_NAME"))

	If mid(server_v1,8,len(server_v2))<>server_v2 Then
		response.write "你提交的路径有误，禁止从站点外部提交数据,请不要乱该参数！"
		response.End
	End If
End Sub 
'检查是否为数字
Sub Check_IsNumeric_Msg(Check_Value,Msg)
	If Not IsNumeric(Check_Value) Or check_value="" Then
		AlertBox Msg&"只能是数字","javascript:history.go(-1)"
	End If
End Sub 
'*****************************************************************
'** 函数名: Check_Length
'** 功能描述:检查变量长度和是否允许为空
'** 调用示例：
'**		Check_Length(sHC_Name,10,1,"城市名称")
'参数含义:
'		Str,Length,MustHave,Check_Field

Sub Check_Length(Str,Length,MustHave,Check_Field)
	Dim i
	Dim VLength

	Str=get_str(Str)

	If MustHave=1 Then
		If Str="" Then
			AlertBox "请输入"&Check_Field&"","javascript:history.go(-1)"
		End If
	End If

	VLength = Len(Str)

	IF Int(VLength) > Int(Length) Then 		
		AlertBox Check_Field&"的长度不能超过"&Length&"个字符","javascript:history.go(-1)"
	End If
End Sub

'*****************************************************************
'** 函数名: MyRadioList
'** 功能描述:根据传入的参数值，生成下RadioList 列表,并选择当前值来显示
'** 调用示例：
'**		Check_Box_List "Hotel_Star","5,4,3,2,1,0","五星,四星,三星,二星,一星,未评级",Hotel_Star
'参数含义:
'		 RadioName,optionValueList,optionNameList,CheckedValue

Sub Check_Box_List(Check_Box_Name,optionValueList,optionNameList,CheckedValue )
	dim aa()
	GetArrayCell optionValueList,",",aa
	
	dim bb()
	GetArrayCell optionNameList,",",bb

	dim i,CR
	CR=Chr(13)&Chr(10)
	'writebr CheckedValue
	for i=0 to UBound(aa)
		response.write "<input name="""&Check_Box_Name&""" type=""checkbox""  value="""&aa(i)&""" "&Get_Checked_Like(aa(i),CheckedValue)&">"&bb(i)&"&nbsp;"
	Next
	

End Sub


'*****************************************************************
'** 函数名: MyRadioList
'** 功能描述:根据传入的参数值，生成下RadioList 列表,并选择当前值来显示
'** 调用示例：
'**		MyRadioList "Hotel_Star","5,4,3,2,1,0","五星,四星,三星,二星,一星,未评级",Hotel_Star
'参数含义:
'		 RadioName,optionValueList,optionNameList,CheckedValue

Sub MyRadioList(RadioName,optionValueList,optionNameList,CheckedValue )
	dim aa()
	GetArrayCell optionValueList,",",aa
	
	dim bb()
	GetArrayCell optionNameList,",",bb

	dim i,CR
	CR=Chr(13)&Chr(10)

	for i=0 to UBound(aa)
		response.write "<input name="""&RadioName&""" type=""radio"" class=""radio"" value="""&aa(i)&""" "&GetChecked(aa(i),CheckedValue)&">"&bb(i)&"&nbsp;"
	Next
	

End Sub

'*****************************************************************
'** 函数名: AjaxSelected_BySql_With_Style
'** 功能描述:根据传入的参数值，生成下List/Menu下拉角色框,并选择当前值来显示
'** 调用示例：
'**		AjaxSelected_BySql_With_Style "HC_Name","SELECT HC_Name,HC_Name FROM Hotel_City ORDER BY HC_NAME ASC","全部",Hotel_City,Change_Method,Style
'参数含义:

Sub AjaxSelected_BySql_With_Style(SelectName,SelectSql,SelectAllValue,SelectedValue,Change_Method,Style_Value )
	
	Dim  i,CR,rsTemp,ItemValue,ItemName

	CR=Chr(13)&Chr(10)

	'writebr SelectSql


	Set rsTemp = conn.execute(SelectSql)

	response.write "<select name='"& SelectName &"' id='"& SelectName &"' size='1'"
	If Change_Method<>"" Then	response.write " onchange="""& Change_Method &";"""

	If Style_Value<>"" Then 
		'response.write " style="""&Style_Value&""" "	
	End If

	response.write ">"&CR

	If get_str(SelectAllValue) <>"" Then
		response.write "	<option value=''"
		if SelectedValue="" then response.write " SELECTED"
		response.write ">"&SelectAllValue&"</option>"&CR
	End If


	SelectedValue = get_str(SelectedValue)

	Do While Not rsTemp.Eof

		ItemValue = get_str(rsTemp(0))
		ItemName  = get_str(rsTemp(1))		
		
		response.write "	<option value='"& ItemValue &"'"
		if trim(ItemValue) = trim(SelectedValue) then response.write " selected" 
		response.write ">"& ItemName &"</option>"&CR

		rsTemp.movenext
	Loop

	rsTemp.close
	Set rsTemp = Nothing 
	
	response.write "</select>"&CR
End Sub



'*****************************************************************
'** 函数名: AjaxSelected_BySql
'** 功能描述:根据传入的参数值，生成下List/Menu下拉角色框,并选择当前值来显示
'** 调用示例：
'**		AjaxSelected_BySql "HC_Name","SELECT HC_Name,HC_Name FROM Hotel_City ORDER BY HC_NAME ASC","全部",Hotel_City,Change_Method
'参数含义:

Sub AjaxSelected_BySql(SelectName,SelectSql,SelectAllValue,SelectedValue,Change_Method )
	
	Dim  i,CR,rsTemp,ItemValue,ItemName

	CR=Chr(13)&Chr(10)
	Set rsTemp = conn.execute(SelectSql)

	response.write "<select name='"& SelectName &"' id='"& SelectName &"' size='1'"
	If Change_Method<>"" Then	response.write " onchange="""& Change_Method &";"""
	response.write ">"&CR

	If get_str(SelectAllValue) <>"" Then
		response.write "	<option value=''"
		if SelectedValue="" then response.write " SELECTED"
		response.write ">"&SelectAllValue&"</option>"&CR
	End If


	SelectedValue = get_str(SelectedValue)

	Do While Not rsTemp.Eof

		ItemValue = get_str(rsTemp(0))
		ItemName  = get_str(rsTemp(1))		
		
		response.write "	<option value='"& ItemValue &"'"
		if trim(ItemValue) = trim(SelectedValue) then response.write " selected" 
		response.write ">"& ItemName &"</option>"&CR

		rsTemp.movenext
	Loop

	Set rsTemp = Nothing 
	
	response.write "</select>"&CR
End Sub

'*****************************************************************
'** 函数名: Selected_BySql
'** 功能描述:根据传入的参数值，生成下List/Menu下拉角色框,并选择当前值来显示
'** 调用示例：
'**		Selected_BySql "HC_Name","SELECT HC_Name,HC_Name FROM Hotel_City ORDER BY HC_NAME ASC","全部",Hotel_City
'参数含义:
'		 SelectName,SelectSql,SelectAllValue,SelectedValue

Sub Selected_BySql(SelectName,SelectSql,SelectAllValue,SelectedValue )
	
	Dim  i,CR,rsTemp,ItemValue,ItemName

	CR=Chr(13)&Chr(10)
	
	Set rsTemp = conn.execute(SelectSql)

	response.write "<select name='"& SelectName &"' size='1'>"&CR
	If get_str(SelectAllValue) <>"" Then
		response.write "	<option value=''"
		if SelectedValue="" then response.write " SELECTED"
		response.write ">"&SelectAllValue&"</option>"&CR
	End If


	SelectedValue = get_str(SelectedValue)

	Do While Not rsTemp.Eof

		ItemValue = get_str(rsTemp(0))
		ItemName  = get_str(rsTemp(1))		
		
		response.write "	<option value='"& ItemValue &"'"
		if trim(ItemValue) = trim(SelectedValue) then response.write " selected" 
		response.write ">"& ItemName &"</option>"&CR

		rsTemp.movenext
	Loop

	Set rsTemp = Nothing 
	
	response.write "</select>"&CR

End Sub


'*****************************************************************
'** 函数名: Selected_BySql_WithCT
'** 功能描述:根据传入的参数值，生成下List/Menu下拉角色框,并选择当前值来显示带入样式表Class 和Style
'** 调用示例：
'**		Selected_BySql_WithCT "HC_Name","SELECT HC_Name,HC_Name FROM Hotel_City ORDER BY HC_NAME ASC","全部",Hotel_City,"input04","border:1px solid #FF9900"
'参数含义:
'		 SelectName,SelectSql,SelectAllValue,SelectedValue

Sub Selected_BySql_WithCT(SelectName,SelectSql,SelectAllValue,SelectedValue,Class_Name,Style_Value )
	
	Dim  i,CR,rsTemp,ItemValue,ItemName

	CR=Chr(13)&Chr(10)
	
	Set rsTemp = conn.execute(SelectSql)

	response.write "<select name='"& SelectName &"' size='1'"
	If Class_Name<>"" Then 
		response.write " Class="""&Class_Name&""" "
	End If
	If Style_Value<>"" Then 
		response.write " style="""&Style_Value&""" "
	End If
	
	response.write ">"&CR
	If get_str(SelectAllValue) <>"" Then
		response.write "	<option value=''"
		if SelectedValue="" then response.write " SELECTED"
		response.write ">"&SelectAllValue&"</option>"&CR
	End If


	SelectedValue = get_str(SelectedValue)

	Do While Not rsTemp.Eof

		ItemValue = get_str(rsTemp(0))
		ItemName  = get_str(rsTemp(1))		
		
		response.write "	<option value='"& ItemValue &"'"
		if trim(ItemValue) = trim(SelectedValue) then response.write " selected" 
		response.write ">"& ItemName &"</option>"&CR

		rsTemp.movenext
	Loop

	Set rsTemp = Nothing 
	
	response.write "</select>"&CR
End Sub

'*****************************************************************
'** 函数名:  GetArrayCell
'** 功能描述:将以某符号（如逗号）分隔的字符串，折分到一维数组aa()中,并返回数组aa()值
'** 调用示例：
'	若字符串是由用户输入的,可能要用到此类语句先作转换：s=Replace(s, "，" , ",")
'	dim i,aa()
'	GetArrayCell "sadfkaa,123,332kkk",",",aa
'
'	for i=0 to Ubound(aa)	
'		response.write aa(i)&" <br>"
'	next
'*****************************************************************
Sub GetArrayCell(s,separator,aa)
	dim i,p,s2
	'dim aa() '放到过程外，作参数传入
	s2=s
	i=0
	p=0	
	do
		redim Preserve aa(i)
		s2=mid(s2,p+1,Len(s2)-p)
		p=instr(s2,separator)
		if p<>0 then
			aa(i)=trim(mid(s2,1,p-1))
		else
			aa(i)=trim(s2)
			exit do
		end if
		i=i+1
	loop while 1=1
End Sub


'*****************************************************************
'** 函数名: MySelected
'** 功能描述:根据传入的参数值，生成下List/Menu下拉角色框,并选择当前值来显示
'** 调用示例：
'**		MySelected "IsAgree","Y,N","同意,不同意","全部",IsAgree
'参数含义:
'		 SelectName,optionValueList,optionNameList,SelectAllValue,SelectedValue

Sub MySelected(SelectName,optionValueList,optionNameList,SelectAllValue,SelectedValue )
	dim aa()
	GetArrayCell optionValueList,",",aa
	
	dim bb()
	GetArrayCell optionNameList,",",bb

	dim i,CR
	CR=Chr(13)&Chr(10)
	
	If IsNull(SelectedValue) Then SelectedValue=""
	response.write "<select name='"& SelectName &"' size='1'>"&CR

	If get_str(SelectAllValue) <>"" Then
		response.write "	<option value=''"
		if SelectedValue="" then response.write " SELECTED"
		response.write ">"&SelectAllValue&"</option>"&CR
	End If

	for i=0 to UBound(aa)
		response.write "	<option value='"& aa(i) &"'"
		If ISNULL(aa(i)) Then aa(i)=""
		if trim( Cstr(aa(i)) )=trim(cstr(SelectedValue)) then response.write " selected" 
		response.write ">"& bb(i) &"</option>"&CR

	next
	response.write "</select>"&CR
End Sub


'*****************************************************************
'** 函数名: MySelected_With_Style
'** 功能描述:根据传入的参数值，生成下List/Menu下拉角色框,并选择当前值来显示,带style
'** 调用示例：
'**		MySelected "IsAgree","Y,N","同意,不同意","全部",IsAgree
'参数含义:
'		 SelectName,optionValueList,optionNameList,SelectAllValue,SelectedValue

Sub MySelected_With_Style(SelectName,optionValueList,optionNameList,SelectAllValue,SelectedValue,Style_Value )
	dim aa()
	GetArrayCell optionValueList,",",aa
	
	dim bb()
	GetArrayCell optionNameList,",",bb

	dim i,CR
	CR=Chr(13)&Chr(10)
	
	If IsNull(SelectedValue) Then SelectedValue=""
	response.write "<select name='"& SelectName &"' size='1'"

	If Style_Value<>"" Then 
		'response.write " style="""&Style_Value&""" "	
	End If

	response.write ">"&CR

	If get_str(SelectAllValue) <>"" Then
		response.write "	<option value=''"
		if SelectedValue="" then response.write " SELECTED"
		response.write ">"&SelectAllValue&"</option>"&CR
	End If

	for i=0 to UBound(aa)
		response.write "	<option value='"& aa(i) &"'"
		If ISNULL(aa(i)) Then aa(i)=""
		if trim( Cstr(aa(i)) )=trim(cstr(SelectedValue)) then response.write " selected" 
		response.write ">"& bb(i) &"</option>"&CR

	next
	response.write "</select>"&CR
End Sub
'*****************************************************************
'** 函数名: Ajax_MySelected
'** 功能描述:根据传入的参数值，生成下List/Menu下拉角色框,并选择当前值来显示
'** 调用示例：
'**		Ajax_MySelected "IsAgree","Y,N","同意,不同意","全部",IsAgree,Ajax_Method
'参数含义:
'		 SelectName,optionValueList,optionNameList,SelectAllValue,SelectedValue,Ajax_Method

Sub Ajax_MySelected(SelectName,optionValueList,optionNameList,SelectAllValue,SelectedValue,Ajax_Method )
	dim aa()
	GetArrayCell optionValueList,",",aa
	
	dim bb()
	GetArrayCell optionNameList,",",bb

	dim i,CR
	CR=Chr(13)&Chr(10)

	response.write "<select name='"& SelectName &"' size='1' onchange="""& Ajax_Method &";"">"&CR

	If get_str(SelectAllValue) <>"" Then
		response.write "	<option value=''"
		if SelectedValue="" then response.write " SELECTED"
		response.write ">"&SelectAllValue&"</option>"&CR
	End If

	for i=0 to UBound(aa)
		response.write "	<option value='"& aa(i) &"'"
		If ISNULL(aa(i)) Then aa(i)=""
		if trim( Cstr(aa(i)) )=trim(cstr(SelectedValue)) then response.write " selected" 
		response.write ">"& bb(i) &"</option>"&CR

	next
	response.write "</select>"&CR
End Sub
Function GetChecked(VAL1,VAL2)

	If IsNull(VAL1) Then VAL1 = ""
	If IsNull(VAL2) Then VAL2 = ""

	If VAL2<>"" Then 
		if ( trim(CStr(VAL1))=trim(CStr(VAL2)) ) then 'radio OR checkbox
			GetChecked= " Checked"
		End If
	Else
		GetChecked=""
	End If

End Function

Function Get_Checked_Like(VAL1,VAL2)

	If IsNull(VAL1) Then VAL1 = ""
	If IsNull(VAL2) Then VAL2 = ""

	If VAL2<>"" Then 
		if ( trim(CStr(VAL1))=trim(CStr(VAL2)) ) Or  (InStr(VAL2,VAL1)>0) then 'radio OR checkbox
			Get_Checked_Like= " Checked"
		End If
	Else
		Get_Checked_Like=""
	End If

End Function

Function GetSelected(VAL1,VAL2)	
	if ( trim(VAL1)=trim(VAL2) ) OR ( Instr(trim(VAL1),trim(VAL2) )>0 ) then 'option of select
		GetSelected=" Selected"
	else
		GetSelected=""
	end if
End Function


'*****************************************************************
'** 函数名: GetSpace
'** 功能描述: 获得Num个&nbsp;(空格)字符串
'** 调用示例：space=GetSpace(6)
'*****************************************************************
Function GetSpace(Num)
	dim i
	for i=1 to Num
		GetSpace=GetSpace&"&nbsp;"
	next
End Function

'department=requery("department")
Function requery(str)	
	requery = Trim(get_safecode(Request.QueryString(str)))
end Function

'department=reform("department")
Function reform(str)
	reform = Trim(get_safecode(Request.Form(str)))
End Function


Sub WriteBR(str)
	If IsObject(str) Then 
		Response.Write "Is Object"
		Exit Sub 
	End If 
	If IsArray(str) Then 
		Response.Write "IsArray:<br>"
		For TempI = 0 To UBound(str)
			Response.Write str(TempI)&"<br>"
		Next 
		Exit Sub 
	End If 
	Response.Write "<BR>" & str 
End Sub


Sub Endd()
	Response.End
End Sub


'** 调用示例：sql=LikeSql("department", trim(request.form("department")),sql)
'*****************************************************************
Function LikeSql(Fields_name,Fields_value,sql)
	if Fields_value<>"" then
		sql=sql & " AND " & Fields_name & " LIKE '%" & Fields_value & "%'"
	end if
	LikeSql=sql
End Function

'字符相等
'** 调用示例：sql=EqualSql("department", trim(request.form("department")),sql)
'*****************************************************************
Function EqualSql(Fields_name,Fields_value,sql)
	if Fields_value<>"" then
		sql=sql & " AND " & Fields_name & " = '" & Fields_value & "'"
	end if
	EqualSql=sql
End Function


'数字相等
'** 调用示例：sql=N_EqualSql("department", trim(request.form("department")),sql)
'*****************************************************************
Function N_EqualSql(Fields_name,Fields_value,sql)
	if Fields_value<>"" then
		sql=sql & " AND " & Fields_name & " = " & Fields_value 
	end if
	N_EqualSql=sql
End Function


'**		sql=DateSql("shipment_date", trim(request.form("query_date1")),trim(request.form("query_date2")),sql)
'*****************************************************************
Function DateSql(Fields_name,Fields_value1,Fields_value2,sql)
	if isdate(Fields_value1) and isdate(Fields_value2)  then
		sql=sql & " AND (" & Fields_name & " >= '" & Fields_value1 & "'"
		sql=sql & " AND " & Fields_name & " <= '" & Fields_value2 & "')"
	end if
	DateSql=sql
End Function


'**		sql=DateSql("shipment_date", trim(request.form("query_date1")),trim(request.form("query_date2")),sql)
'*****************************************************************
Function BetweenSql(Fields_name,Fields_value1,Fields_value2,sql)

	If IsNumeric(Fields_value1) Then
		sql=sql & " AND " & Fields_name & " >= " & Fields_value1 
	end If

	If IsNumeric(Fields_value2) Then
		sql=sql & " AND " & Fields_name & " <= " & Fields_value2 
	end If
	
	BetweenSql=sql

End Function



Function check_null(ByVal checkstr)
  check_null = False
  If IsNull(checkstr) Then
    check_null = True
  Else
    If Trim(checkstr) = "" Then check_null = True
  End If
End Function

Function delete_file(ByVal strers)
  On Error Resume Next
  delete_file = False
  Dim tmpfso, tmppath,s_tmppath
  s_tmppath = Replace(strers,".","_s.")

  tmppath   = server.MapPath(strers)
  s_tmppath = server.MapPath(s_tmppath)

  Set tmpfso = server.CreateObject("Scripting.FileSystemObject")
  If not Err Then
    If tmpfso.fileexists(tmppath) Then
      tmpfso.DeleteFile(tmppath)
      delete_file = True
    End If

    If tmpfso.fileexists(s_tmppath) Then
      tmpfso.DeleteFile(s_tmppath)
      delete_file = True
    End If

  End If
  Set tmpfso = Nothing
End Function


Function encode_article(ByVal strers)
  Dim tstrer: tstrer = strers
  If check_null(tstrer) Then
    encode_article = ""
  Else
    tstrer = Replace(tstrer, Chr(39), "&#39;")
    tstrer = Replace(tstrer, Chr(32) & Chr(32), "&nbsp;&nbsp;")
    tstrer = Replace(tstrer, Chr(13) & Chr(10), "<br/>")
    tstrer = Replace(tstrer, Chr(10), "<br/>")
	encode_article = tstrer

   End If
  'tstrer = encode_html(tstrer)	
  
End Function

Function encode_html(ByVal strers)
  Dim tstrer: tstrer = strers
  If check_null(tstrer) = "" Then
    encode_html = ""
  Else
    tstrer = Replace(tstrer, "&", "&amp;")
    tstrer = Replace(tstrer, ">", "&gt;")
    tstrer = Replace(tstrer, "<", "&lt;")
    tstrer = Replace(tstrer, """", "&quot;")
    encode_html = tstrer
  End If
End Function

Function encode_forscript(ByVal strers)
  Dim tstrer: tstrer = get_str(strers)
  tstrer = Replace(tstrer, "\", "&#92;")
  tstrer = replace(tstrer, "'", "\'")
  tstrer = replace(tstrer, """", "\""")
  encode_forscript = tstrer
End Function


Function CutStr(str,strlen)
	dim l,t,c,i
	If Len(str)=0 Or IsNull(str) Then
		CutStr = ""
		Exit function
	End if
	l=len(str)
	t=0
	for i=1 to l
		c=Abs(Asc(Mid(str,i,1)))
		if c>255 then
			t=t+2
		else
			t=t+1
		end if
		if t>=strlen then
			cutStr=left(str,i)&"..."
			exit for
		else
			cutStr=str
		end if
	next
End Function
Function CutStrNone(str,strlen)
	dim l,t,c,i
	If Len(str)=0 Or IsNull(str) Then
		CutStrNone = ""
		Exit function
	End if
	l=len(str)
	t=0
	for i=1 to l
		c=Abs(Asc(Mid(str,i,1)))
		if c>255 then
			t=t+2
		else
			t=t+1
		end if
		if t>=strlen then
			CutStrNone=left(str,i)
			exit for
		else
			CutStrNone=str
		end if
	next
End Function

'生成随机数字，n为数字的个数
Function MyRand(n) 
	dim thechr
	thechr = ""
	for i=1 to n
		dim zNum,zNum2
		Randomize
		zNum = cint(9*Rnd)
		zNum = zNum + 48
		thechr = thechr & chr(zNum)
	next
	MyRand = thechr
End Function


Function get_clientip()
	client_ip = request.servervariables("http_x_forwarded_for")
	If client_ip = "" then client_ip = request.servervariables("remote_addr")
	get_clientip = client_ip
End Function 


Function get_str(ByVal strers)
  If check_null(strers) Then
    get_str = ""
  Else
    get_str = CStr(strers)
  End If
End Function




Function get_safecode(ByVal strers)
  Dim strer
  strer = strers
  If check_null(strer) Then
    get_safecode = ""
  Else
	strers		 = ReplaceBad(strers)
	strers		 = Replace(strers,"'","''")
	get_safecode = strers
  End If
End Function

Function ReplaceBad(str)    
	Dim VarStr,Strs,T_String,i
	T_String = str
	BadStrs ="'|--|and"
	Strs = Split(BadStrs,"|")
	For i=0 To Ubound(Strs)
		T_String=Replace(T_String,Strs(i),"")
	Next
	ReplaceBad = T_String
End Function


''''''''''替换模块START''''''''''''
Function ReplaceText(fString,patrn,replStr)
	Set regEx = New RegExp   	' 建立正则表达式。
		regEx.Pattern = patrn   ' 设置模式。
		regEx.IgnoreCase = True ' 设置是否区分大小写。
		regEx.Global = True     ' 设置全局可用性。 
		ReplaceText = regEx.Replace(""&fString&"",""&replStr&"") ' 作替换。
	Set regEx=nothing
End Function
''''''''''替换模块END''''''''''''

Function get_rndcode(ByVal slen)
  Dim basecode, baseary, lbase, li, lrnd, tmpstr
  basecode = "0,1,2,3,4,5,6,7,8,9,a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z"
  baseary = Split(basecode, ",")
  lbase = UBound(baseary)
  For li = 1 To slen
    Randomize
    lrnd = Rnd
    lrnd = Int(lrnd * (lbase - 1))
    tmpstr = tmpstr & baseary(lrnd)
  Next
  get_rndcode = tmpstr
End Function


'--------------文章显示分页调用---------------
'------------------调用-----------------------
'在文章里加入分页标志
'{nextpage}
'Dim id
'id = request.QueryString("id")
'str = "第一页:这里是第一页的内容{nextpage}第二页:这里是第二页的内容{nextpage}第三页:这里是第三页的内容"
'str = "第一页:这里是第一页的内容第二页:这里是第二页的内容第三页:这里是第三页的内容"

'url = Request.ServerVariables("URL")&"?id="&id&"&"

'Show_Article_Page str

Sub Show_Article_Page(str)

		page = request.QueryString("p")

		query_arr = Split(Request.ServerVariables("QUERY_STRING"),"&")

		my_query_string = ""

		For i = 0 To UBound(query_arr)
			'writebr query_arr(i)
			If InStr(query_arr(i),"p=")=0 Then 
				my_query_string = my_query_string & "&"&query_arr(i)
			End If
		Next

		If Len(my_query_string)>0 Then 
			If Mid(my_query_string,1,1)="&" Then 
				my_query_string = Mid(my_query_string,2,Len(my_query_string))
			End If
		End If

		url = Request.ServerVariables("SCRIPT_NAME") & "?" &my_query_string
		if not isnumeric(page) then
			Response.Write ("<script language=javascript>alert('提示:错误的参数!');history.go(-1)</script>")
		end If
		
		if page="" or page=0 or isnull(page) or isempty(page) then
			page=1
		else
			page=cint(page)
		end If
		str=split(str,"{nextpage}")
		abspage=page
		pcount=ubound(str)+1

		if page>cint(ubound(str)+1) or page<1 then
			'Response.Write ("<script language=javascript>alert('提示:错误的参数!');history.go(-1)</script>")
		Else
			response.write str(page-1)	
			If pcount>1 Then  '大于2页才显示分页

				'response.write "<br><br><center> 共分为"&pcount&"页"
				response.write "<div align=center style='font-size:14px'>"

				If abspage>1 Then
					response.write "<A HREF="""&url&"&p="&abspage-1&"""><img src=""../images/article_p_page.gif"" width=""69"" height=""21"" border=""0"" alt=""浏览上一页"" align=""absmiddle""></A>  "

				End If
				for p=0 to ubound(str)
					
					If abspage<>p+1 Then 	
						response.write "<a href="&url&"&p="&p+1&"><font style='font-size:14px'>["&p+1&"]</font></a> "
					Else
						response.write "["&p+1&"] "
					End If

				Next
				
				If abspage<pcount Then
					response.write "<A HREF="""&url&"&p="&abspage+1&"""><img src=""../images/article_n_page.gif"" width=""69"" height=""21"" border=""0"" alt=""浏览下一页"" align=""absmiddle""></A>"
				End If

				'response.write "当前第"&abspage&"/"&pcount&"页</center>"
				response.write "</div>"
			End If
		end If
		
End Sub






'*****************************************************************
'** 函数名:AlertBox
'** 功能描述:显示提示信息，并根据URL参数值选择去向
'**	AlertBox函数不能放在 conn.BeginTrans 和 conn.CommitTrans 之间，否则，会出错！
'** 调用示例：
'	AlertBox "修改成功!","javascript:history.go(-1)"
'	AlertBox "保存成功!","XXX.asp"
'	AlertBox "修改成功!",""
'*****************************************************************

Sub AlertBox(Msg,URL)
	dim CR
	CR=Chr(13)&Chr(10)

	Call conn_close()

	response.write "<script language='javascript'>" & CR
	response.write "	alert('"& Msg &"');" & CR
	if URL<>"" then
		response.write "	window.document.location.href='"& URL &"';" & CR
	end if
	response.write "</script>" & CR
	Response.End
End Sub

'*****************************************************************
'** 函数名: Sort
'** 功能描述:对数给进行排序
'**	参数说明:arr  传入数组  u 排序字段
'*****************************************************************

Function Sort(arr,u)
  Dim UNum1,UNum2
  Dim UTrue,A1,A2
  IF Not IsArray(arr) Then Exit Function
  IF Not IsNumeric(u) Then u = 0
  UNum1 = UBound(arr)
  UNum2 = UBound(arr,2)
  ReDim Arr1(UNum1),Arr2(UNum1),Arr3(UNum1,UNum2)
  For i = 0 To UNum1
    Arr1(i) = arr(i,u)
    Arr2(i) = i
  Next
  UTrue = True
  Do Until Not UTrue
    UTrue = False
    For i = 0 To UNum1
      IF i = UNum1 Then Exit For
      IF Arr1(i) > Arr1(i+1) Then
        A1 = Arr1(i):Arr1(i) = Arr1(i+1):Arr1(i+1) = A1
        A2 = Arr2(i):Arr2(i) = Arr2(i+1):Arr2(i+1) = A2
        UTrue = True
      End IF
    Next
  Loop
  For i = 0 To UNum2
    For n = 0 To UNum1
      Arr3(n,i) = arr(Arr2(n),i)
    Next
  Next
  Sort = Arr3
End Function



Function RemoveHTML(strHTML)    '过滤HTML代码的函数包括过滤CSS和JS 

	StrHtml = Replace(StrHtml,vbCrLf,"") 
	StrHtml = Replace(StrHtml,Chr(13)&Chr(10),"") 
	StrHtml = Replace(StrHtml,Chr(13),"") 
	StrHtml = Replace(StrHtml,Chr(10),"") 
	StrHtml = Replace(StrHtml," ","") 
	StrHtml = Replace(StrHtml,"    ","") 

	Dim objRegExp, Match, Matches  
	Set objRegExp = New Regexp 
	  
	objRegExp.IgnoreCase = True 
	objRegExp.Global = True 

	'取闭合的<> 
	objRegExp.Pattern = "<style(.+?)/style>" 
	'进行匹配 
	Set Matches = objRegExp.Execute(strHTML) 
	  
	' 遍历匹配集合，并替换掉匹配的项目 
	For Each Match in Matches  
	strHtml=Replace(strHTML,Match.Value,"") 
	Next 

	  '取闭合的<> 
	objRegExp.Pattern = "<script(.+?)/script>" 
	'进行匹配 
	Set Matches = objRegExp.Execute(strHTML) 
	  
	' 遍历匹配集合，并替换掉匹配的项目 
	For Each Match in Matches  
	strHtml=Replace(strHTML,Match.Value,"") 
	Next 

	  '取闭合的<> 
	objRegExp.Pattern = "<.+?>" 
	'进行匹配 
	Set Matches = objRegExp.Execute(strHTML) 
	  
	' 遍历匹配集合，并替换掉匹配的项目 
	For Each Match in Matches  
	strHtml=Replace(strHTML,Match.Value,"") 
	Next 

	RemoveHTML=strHTML 
	Set objRegExp = Nothing 

End Function 

'*****************************************************************
'** 函数名: GetRndString
'** 功能描述:生成L位的随机字符串,设置密码用
'*****************************************************************
function GetRndString(L)

	if not IsNumeric(L) then
		GetRndString=""	
		exit function
	end if


	dim chars
	chars="0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"	'共84个字符


	dim i,RndString
	dim aaRnd

	RndString=""
	for i=1 to L

	
		Randomize '设置随机因子

		aaRnd=INT( LEN(chars) * Rnd  ) + 1 
	'	writeBR aaRND

		if cdbl(aaRnd)<1 then aaRnd=1
		if cdbl(aaRnd)>LEN(chars) then aaRnd=LEN(chars)

		RndString=RndString & MID(chars,aaRnd,1)

	next

	GetRndString = GetSn(trim(RndString) , L)

	'若随机数错误,则取数字
	if Len(GetRndString)<L then GetRndString=GetRndNum(L)	

end function 

Function GetSn(Sn,n)

	Sn=trim(Sn)
	GetSn=String(n-Len(Sn),"0") & Cstr(Sn)	'n-Len(Sn):需要添加前缀"0"的个数

End Function


Function SendMail(ToMail,ToName,FromMail,FromName,Subject,Body,Attachment)

	Set Mail = server.createobject("Jmail.Message")

	Host = "smtp.hainan.com"

	Mail.MailServerUserName = "dot@hainan.com"
	Mail.MailServerPassword = "dotlove@com"

	Mail.Charset="gb1213"	
	Mail.ContentType = "text/html"  '邮件的格式为HTML的

	Mail.From	  = FromMail '发件地址要和	MailServerUserName 一致
	Mail.FromName = Fromname '可选
	Mail.AddRecipient ToMail 'ToName可选

	if Attachment<>"" then
		Mail.AddAttachment Attachment 	'附件,如,"c:\a.doc"
	end if

	Mail.Subject = Subject
	Mail.Body = Body
	'Mail.IsHTML = True 'Html型内容

	On Error Resume Next

	Mail.Send(Host)   
	Mail.Close()

	If Err.Number <> 0 Then 
		SendMail=0
	Else

		SendMail=1
	End If

	Set Mail=Nothing

End Function



Function CodeCookie(str) 
	Dim i 
	Dim strRtn 
	for i=len(str) to 1 step -1 
		strRtn=strRtn & ascw(mid(str,i,1)) 
		if (i<>1) then strRtn = strRtn & "a" '用a作分隔符 
	next 
	CodeCookie=strRtn 
End Function 

'解码程序 
Function DecodeCookie(str) 
	Dim i 
	Dim strArr,strRtn 
	strArr=Split(str,"a")
	for i=UBound(strArr)-LBound(strArr) to 1 step -1 
	strRtn=strRtn & chrw(Val(strArr(i))) 
	next 
	DecodeCookie=strRtn 
End Function 

'================================================================
' 传统分页方法 简单分页
'在外部定义以下变量
'rs_recordcount '记录数量
'rs_PostString	'查询变量保存
'rs_PageCount	'页数
'rs_PageCurr	'当前页
'================================================================
Sub rs_Page()
	Dim Array_PostString,sQueryString
	sQueryString = ""

	If rs_recordcount>0   Then

		Array_PostString = split(rs_PostString,"|")
		If Request.ServerVariables ("Request_Method")="POST" Then

			For i=0 To ubound(Array_PostString)
				sQueryString = sQueryString &"<INPUT TYPE='hidden' name="&Array_PostString(i)&" value='"&reform(Array_PostString(i))&"'>"&Chr(13)&Chr(10)
			Next
		Else
			For i=0 To ubound(Array_PostString)
				sQueryString = sQueryString &"<INPUT TYPE='hidden' name="""&Array_PostString(i)&""" value="""&requery(Array_PostString(i))&""">"&Chr(13)&Chr(10)
			Next
		End If 
		Response.Write "<Script Language=""JavaScript"" type=""text/JavaScript"">"

		Response.Write "function GoPage(){"
		Response.Write "	var page=document.pagefrm.page.value;"
		Response.Write "	var max_Page="&rs_PageCount&";"
		Response.Write "	if (page>0 && page<=max_Page){"
		Response.Write "		document.pagefrm.submit();"
		Response.Write "		}"
		Response.Write "	else{"
		Response.Write "		alert(""页码不在合法范围内！"");"
		Response.Write "		return false;"
		Response.Write "	}"
		Response.Write "}"
		Response.Write "function Page(page){"
		Response.Write "	document.pagefrm.page.value=page;"
		Response.Write "	GoPage();"
		Response.Write "}"
		Response.Write "</Script>"

		Response.Write "<form action="""" method=""Post"" name=""pagefrm"" onsubmit=""return GoPage();"">"
			

		Response.Write "<INPUT TYPE=""hidden"" NAME=""page"" size=>"


		If rs_PageCurr>1 Then
			Response.write "<a href=""#"" onclick=""Page("&rs_PageCurr-1&")"&"""><  Prev</a> "
		Else
			Response.write "<a href=""#"" onclick=""return false;""><  Prev</a> "
		End If 

		If rs_PageCurr>6 Then
			xi = rs_PageCurr-5
			yi = rs_PageCurr+4

			If yi>rs_PageCount Then 
			xi = rs_PageCount-9
			yi = rs_PageCount
			End If
			
			If xi<0 Then  xi=1

			For i= xi  to yi
				If i> rs_PageCount Then Exit For 
				If i=rs_PageCurr Then
					Response.write "<span class=""current"">"&i&"</span>"
				Else
					Response.write "<a href=""#"" onclick=""Page("&i&")"&""">"&i&"</a>"
				End If
				
			 Next

		Else

			For i= 1  to 10 
				If i> rs_PageCount Then Exit For 
				If i=rs_PageCurr Then
					Response.write "<span class=""current"">"&i&"</span>"
				Else
					Response.write "<a href=""#"" onclick=""Page("&i&")"&""">"&i&"</a>"
				End If
				
			Next


		End If

		If rs_PageCurr<rs_PageCount Then 
			Response.write "<a href=""#"" onclick=""Page("&rs_PageCurr+1&")"&""">Next  > </a> "
		Else
			Response.write "<a href=""#"" onclick=""return false;"">Next  ></a> "
		End If 

		Response.write sQueryString

		Response.Write "</form>"
	End If
End Sub

'阿拉伯数字转为中文数字
Function NumberToHan(Number)
	Han_Number = ""
	If IsNull(Number) Then 
		NumberToHan = ""
		Exit Function 
	End If

	Select Case Number
		   Case "1"  Han_Number = "一"
		   Case "2"  Han_Number = "二"
		   Case "3"  Han_Number = "三"
		   Case "4"  Han_Number = "四"
		   Case "5"  Han_Number = "五"
		   Case "6"  Han_Number = "六"
		   Case "7"  Han_Number = "七"
		   Case "8"  Han_Number = "八"
		   Case "9"  Han_Number = "九"
		   Case "10"  Han_Number = "十"
		   Case Else  Han_Number = ""
	End Select 
	NumberToHan = Han_Number  
End Function 

Function GetUrl()

	GetUrl = Request.ServerVariables("SCRIPT_NAME")
	IF(Request.ServerVariables("QUERY_STRING")<>"")THEN GetUrl=GetUrl&"?"& Request.ServerVariables("QUERY_STRING")

End Function 

Sub Show_Block_None(super)
	If super="1" Then
		Response.write "style=""DISPLAY: block """
	Else
		Response.write "style=""DISPLAY: none """
	End If
End Sub

Function SqlString(Text)
	SqlString="'" & Text & "'"
End Function

Function Nvl(Text,Def)
  IF ChkEmpty(Text) Then
	 Nvl=Def
  Else
	 Nvl=Text
  End IF 
End Function

Function ChkEmpty(Text)
   IF IsNull(Text) Then 
	  ChkEmpty=true
   Else   
		IF IsEmpty(Text) Or Trim(Text)="" Then
		   ChkEmpty=True
		Else
		   ChkEmpty=False
		End IF
   End IF   
End Function

'取日期
Function Get_Today()
	Dim return_value
	
	return_value = FormatDateTime(Now(),2)
	return_value = "今天是"&Year(Now())&"年"&Get_HowLength(Month(Now()),2)&"月"&Get_HowLength(day(Now()),2)&"日" & Get_festa_Day()
	Get_Today = return_value

End Function 


'补齐长度
Function Get_HowLength(str_Value,Length)
	If IsNull(Length) Or (IsNumeric(Length)=False) Then 
		Get_HowLength = str_Value
		Exit Function
	End If
	pre = ""
	For i = 1 To Length-Len(str_Value)
		Pre = Pre&"0"
	Next
	str_Value = Pre &str_Value
	Get_HowLength =str_Value
End Function

Function Get_Rs_Value(str_Value)
	If IsNull(str_Value) Then 
		Get_Rs_Value = ""
	Else
		Get_Rs_Value = str_Value
	End If
End Function




'----------------------------------------------------------------'
' checkStr
' 过滤特殊字符，主要是去掉 SQL 关键词
' 参数：
' str 需要被过滤的字符串
' 返回值：字符串 (经过过滤后的字符串)
'----------------------------------------------------------------'
Function CheckStr(byVal ChkStr) 
	Dim Str:Str=ChkStr
	If IsNull(Str) Then
		CheckStr = ""
		Exit Function 
	End If
    Str = Replace(Str, "&", "&amp;")
    Str = Replace(Str,"'","&#39;")
    Str = Replace(Str,"""","&#34;")
	Dim re
	Set re=new RegExp
	re.IgnoreCase =True
	re.Global=True
	re.Pattern="(w)(here)"
    Str = re.replace(Str,"$1h&#101;re")
	re.Pattern="(s)(elect)"
    Str = re.replace(Str,"$1el&#101;ct")
	re.Pattern="(i)(nsert)"
    Str = re.replace(Str,"$1ns&#101;rt")
	re.Pattern="(c)(reate)"
    Str = re.replace(Str,"$1r&#101;ate")
	re.Pattern="(d)(rop)"
    Str = re.replace(Str,"$1ro&#112;")
	re.Pattern="(a)(lter)"
    Str = re.replace(Str,"$1lt&#101;r")
	re.Pattern="(d)(elete)"
    Str = re.replace(Str,"$1el&#101;te")
	re.Pattern="(u)(pdate)"
    Str = re.replace(Str,"$1p&#100;ate")
	re.Pattern="(\s)(or)"
    Str = re.replace(Str,"$1o&#114;")
	Set re=Nothing
	CheckStr=Str
End Function

'----------------------------------------------------------------'
' uncheckStr
' 恢复特殊字符，checkStr 函数的逆操作
' 参数：
' str 需要被恢复的字符串
' 返回值：字符串 (恢复原来的字符串)
' 这个一般用在编辑的时候，显示用户输入的原始内容
'----------------------------------------------------------------'
Function UnCheckStr(ByVal Str)
		If IsNull(Str) Then
			UnCheckStr = ""
			Exit Function 
		End If
	    Str = Replace(Str,"&#39;","'")
        Str = Replace(Str,"&#34;","""")
		Dim re
		Set re=new RegExp
		re.IgnoreCase =True
		re.Global=True
		re.Pattern="(w)(h&#101;re)"
	    str = re.replace(str,"$1here")
		re.Pattern="(s)(el&#101;ct)"
	    str = re.replace(str,"$1elect")
		re.Pattern="(i)(ns&#101;rt)"
	    str = re.replace(str,"$1nsert")
		re.Pattern="(c)(r&#101;ate)"
	    str = re.replace(str,"$1reate")
		re.Pattern="(d)(ro&#112;)"
	    str = re.replace(str,"$1rop")
		re.Pattern="(a)(lt&#101;r)"
	    str = re.replace(str,"$1lter")
		re.Pattern="(d)(el&#101;te)"
	    str = re.replace(str,"$1elete")
		re.Pattern="(u)(p&#100;ate)"
	    str = re.replace(str,"$1pdate")
		re.Pattern="(\s)(o&#114;)"
	    Str = re.replace(Str,"$1or")
		Set re=Nothing
        Str = Replace(Str, "&amp;", "&")
    	UnCheckStr=Str
End Function


'----------------------------------------------------------------'
' BoldWord
' 突出显示字符串中查询到的单词
' 参数：
' strContent 查询结果
' word		 查询关键字 
' 返回值：	 字符串 (恢复原来的字符串)
'----------------------------------------------------------------'

Function BoldWord(strContent,word)
   dim objRegExp
   Set objRegExp=new RegExp
   objRegExp.IgnoreCase =true
   objRegExp.Global=True

   objRegExp.Pattern="(" & word & ")"
   strContent=objRegExp.Replace(strContent,"<font color=""#FF0000"">$1</font>" )

   Set objRegExp=Nothing
   BoldWord=strContent
End Function 

'2008-6-9
'判断文件是否存在
Function IsFileExist(ByVal File_Path)
  On Error Resume Next
  IsFileExist = False
  Dim Fso, True_Path
  True_Path = server.MapPath(File_Path)

  Set Fso = server.CreateObject("Scripting.FileSystemObject")
  If not Err Then
    If Fso.fileexists(True_Path) Then
      IsFileExist = True
    End If
  End If
  Set tmpfso = Nothing
End Function

'生成水印图片
'Call Make_WaterMark("/UploadImages/20085752352381.jpg","/UploadImages/Water.Png)

Sub Make_WaterMark(Pic_Path,WaterPic_Path)

	'On Error Resume Next 
	
	If Not (IsNumeric(Water_Width)=True  And  IsNumeric(Water_Height)=True) Then 
		Exit Sub 
	End If 

	If IsFileExist(Pic_Path)=False Or IsFileExist(WaterPic_Path)=False  Then 
		Exit Sub 
	End If

	True_Path  = server.MapPath(Pic_Path)
	Water_Path = server.MapPath(WaterPic_Path)

	Dim Jpeg
	Set Jpeg = Server.CreateObject("Persits.Jpeg")

	' 打开
	Jpeg.Open True_Path


	Set MarkImg = Server.CreateObject("Persits.Jpeg")

	' 读取添加的图片。
	MarkImg.Open Water_Path  

	'REM 处理水印图的大小
	If CInt(Jpeg.OriginalWidth/2)<Cint(MarkImg.OriginalWidth) or CInt(Jpeg.Originalheight/2)<Cint(MarkImg.Originalheight) Then
        Set Jpeg    = Nothing
		Set MarkImg = Nothing 
        Exit Sub
    End If 


	jpeg.Canvas.DrawPNG Jpeg.Width-MarkImg.Width, Jpeg.Height-MarkImg.Height, Water_Path
	 
	' 保存缩略图到指定文件夹下
	Jpeg.Save True_Path

	' 注销实例
	Set Jpeg = Nothing
	Set MarkImg = Nothing 

End Sub 

'生成指定宽高的缩略小图
'Call make_small_pic("/UploadImages/20085752352381.jpg",120,90)

Sub make_small_picxxx(Pic_Path,Width,Height)
	On Error Resume Next 
	If Not (IsNumeric(Width)=True  And  IsNumeric(Height)=True) Then 
		Exit Sub 
	End If 

	If IsFileExist(Pic_Path)=False Then 
		Exit Sub 
	End If

	True_Path = server.MapPath(Pic_Path)

	Dim Jpeg
	Set Jpeg = Server.CreateObject("Persits.Jpeg")

	' 图片所在位置
	s_Path = Replace(True_Path,".","_s.")
	' 打开
	Jpeg.Open True_Path

	'Width = 120
	'Height = 90

	'取原宽高
	s_width  = Jpeg.OriginalWidth
	s_height = Jpeg.OriginalHeight

	If s_width>s_height Then 
		If((s_width/s_height)>(width/height)) Then 
			n_height = height
			n_width  = (s_width/s_height)*height
		Else
			n_width  = width
			n_height = (s_height/s_width)*width	 
		End If 
	Else

		If((s_height/s_width)>(height/width)) Then 
			n_width  = width
			n_height = (s_height/s_width)*width	 
		Else
			n_height = height
			n_width  = (s_width/s_height)*height
		End If 
	End If 

	' 按比例缩放
	Jpeg.Width = n_width
	Jpeg.Height = n_height


	'按指定宽高裁切
	jpeg.Crop 0, 0, width, height 
	
	'设定图片质量
	Jpeg.Interpolation=0   
	Jpeg.Quality=100 

	'设定锐化效果
	Jpeg.Sharpen 1, 110 

	' 保存缩略图到指定文件夹下
	Jpeg.Save s_Path
	'Response.write Jpeg.version

	' 注销实例
	Set Jpeg = Nothing
End Sub 

'生成缩略小图
Sub make_small_pic(Pic_Path,Width,Height)

	data_send = "Pic_Path="&Pic_Path&"&Width="&Width&"&Height=" & Height
	http_host = Request.ServerVariables("http_host")
	url = "http://"&http_host&"/2010admin/Thumbnail/MakeThumbnail.aspx"
	On Error Resume Next 
	Set http = Server.Createobject("MSXML2.XMLHTTP")	
	Http.open "POST",url,false 
	Http.setRequestHeader   "Content-Type",   "application/x-www-form-urlencoded"   
	Http.send(data_send) 
	'Response.Write Http.ResponseText
	'endd
End Sub 
'删除数组里重复的值
Function Get_Distinct_Array(ByVal oldArr)
	
	If IsArray(oldArr)=False  Then 
		Get_Distinct_Array = ""
		Exit Function 
	End If 

	Dim NewArr() 

	ReDim Preserve NewArr(0) 

	NewArr(0) = Trim(oldArr(0)) 

	For i = 1 to UBound(oldArr) 
		MatchArray = Filter(NewArr, Trim(oldArr(i)), True,1) 
		iRepeatFlag = 1 
		For j = 0 To UBound(MatchArray) 
			iRepeatFlag = StrComp(Trim(oldArr(i)), Trim(MatchArray(j)), 1) 
			'一旦发现重复,立刻退出循环 
			If iRepeatFlag = 0 Then 
			Exit For 
			End If 
		Next 

		If IsNull(iRepeatFlag) Then iRepeatFlag = 2 
			If iRepeatFlag <> 0 Then 
			ReDim Preserve NewArr(UBound(NewArr) + 1) 
			NewArr(UBound(NewArr)) = Trim(oldArr(i)) 
		End If 
	next 

	Get_Distinct_Array = NewArr

End Function 

Function Is_Admin()
	If Session("Admin_SuperUser")="1" Then 
		Is_Admin = True
	Else
		Is_Admin = False
	End If

End Function 

'***********************************
'**********数据操作过程**************
'***********************************

'取结果集到数组
Function GetRsRows(byVal strSql)

	'用于执行SELECT语句，将数据以数组形式返回
	Set rsTemp = Server.CreateObject("ADODB.recordset")

	rsTemp.CursorType = 0
	rsTemp.ActiveConnection = Conn
	rsTemp.Open   strSql,Conn,0,1

	IF rsTemp.Eof or rsTemp.Bof Then
		GetRsRows = ""
	Else
		GetRsRows = rsTemp.GetRows
	End IF
	rsTemp.Close
	Set rsTemp = Nothing

End Function

'取记录集的首行首列
Function Get_FirstValue(Sql)
	Dim rsTemp
	Set rsTemp = conn.execute(sql)
	If Not rsTemp.Eof Then 
		FirstValue = rsTemp(0)
	Else 
		FirstValue = ""
	End If
	rsTemp.close
	Set rsTemp = Nothing
	Get_FirstValue = FirstValue
End Function 


'增加记录并取得最新ID
Function Insert_And_ReturnID(SqlStr,Table_Name,ID_Field)
	Dim Return_ID
	Return_ID = 0
	'On Error Resume Next
	Conn.execute(SqlStr)
	Set RsTemp = conn.execute("SELECT TOP  1 "&ID_Field&" FROM "&Table_Name&" ORDER BY "& ID_Field &" DESC ")
	If Not rsTemp.Eof Then 
		Return_ID = rsTemp(0)
	End If 
	rsTemp.close
	Set rsTemp = Nothing 
	If Err.Number<>0 Then 
		Insert_And_ReturnID = 0
	Else
		Insert_And_ReturnID = Return_ID
	End If 
End Function 


Sub BeginTrans
	ERR.CLEAR
	conn.BeginTrans '开始事务
	On Error Resume Next 
End Sub

'EndTableTrans "", "", "修改成功!", "javascript:history.go(-1)"


Sub EndTrans(FailMsg,FailURL,SuccessMsg,SuccessURL)
	If Err.Number<>0 Then
		conn.RollBackTrans '回滚事务
		AlertBox FailMsg,FailURL
		Response.End 
	ELSE
		conn.CommitTrans '提交事务
		AlertBox SuccessMsg,SuccessURL
		Response.End 
	END IF
End Sub


'Action 操作说明
'Sql 操作语句
'URL 操作成功后返回来的地址
Sub Db_Execute(Action,Sql,URL)

	On Error Resume Next

    conn.execute(sql)
	If  err.number =0 Then 
		AlertBox Action&"成功！",URL
	Else  
		Call Conn_Close()
		Writebr Action&"失败,错误信息如下："
		Writebr Err.Description
		Writebr "Sql:<br>"&Sql
		endd 
	End If 

	
End Sub 


'**********数据操作过程结束************

Function Get_Current_Act(ByVal Current_Act)

	script_name = Request.ServerVariables("script_name")
	If InStr(script_name,"/")>0 Then 
		script_name_Array = Split(script_name,"/")
		script_name		  = script_name_Array(1)	
		'If UBound(script_name_Array)>1 Then  
		'	script_name= script_name_Array(2) 
		'End If 
	Else

	End If 

	'writebr Act&"="&Current_Act
	If CStr(script_name)=CStr(Current_Act) Then 
		Get_Current_Act = " class=""active"""
	Else
		Get_Current_Act = ""
	End If 
End Function 


Dim Flash_Files
Dim Flash_Links
Dim Flash_Texts

Sub Get_Flash_List()

	'Sql = "SELECT TOP 9 News_ID,News_Title,News_Desc FROM News WHERE News_IsTop=1 ORDER BY Update_Date DESC, News_ID DESC"
	Sql = "SELECT TOP 10 News_ID,News_Title,News_URL,News_PicPath FROM News WHERE News_Type='首页FLASH' ORDER BY Update_Date ASC, News_ID ASC"
	Array_List = GetRsRows(Sql)
	If IsArray(Array_List) Then 
	For i=0 To UBound(Array_List,2)
		Flash_Files = Flash_Files&"|"&Array_List(3,i)
		Flash_Links = Flash_Links&"|"&Array_List(2,i)
		Flash_Texts = Flash_Texts&"|"&Array_List(1,i)
	Next

	If Len(Flash_Files)>1 Then Flash_Files=Mid(Flash_Files,2,Len(Flash_Files))
	If Len(Flash_Links)>1 Then Flash_Links=Mid(Flash_Links,2,Len(Flash_Links))
	If Len(Flash_Texts)>1 Then Flash_Texts=Mid(Flash_Texts,2,Len(Flash_Texts))

	End If 

End Sub 


''''''''''替换模块START''''''''''''
Function ReplaceText(fString,patrn,replStr)
	Set regEx = New RegExp   	' 建立正则表达式。
		regEx.Pattern = patrn   ' 设置模式。
		regEx.IgnoreCase = True ' 设置是否区分大小写。
		regEx.Global = True     ' 设置全局可用性。 
		ReplaceText = regEx.Replace(""&fString&"",""&replStr&"") ' 作替换。
	Set regEx=nothing
End Function
''''''''''替换模块END''''''''''''
Function Get_Current_Info_Type(ByVal Act ,ByVal Current_Act)
	

	If CStr(Act)=CStr(Current_Act) Then 
		Get_Current_Info_Type = " class=""active_c"""
	Else
		Get_Current_Info_Type = ""
	End If 
End Function 
Function Get_SmallPic(tmp_filename)
	If IsNull(tmp_filename) Or tmp_filename="" Then 
		tmp_filename = ""		
	Else
		tmp_filename = Replace(tmp_filename,".","_t.")
	End If 

	Get_SmallPic = tmp_filename
End Function 

'论坛列表
Sub Forum_List(ForumID)

	Selected_BySql "ForumID","SELECT ForumID,ForumName FROM Forum_Forums ORDER BY ForumID ASC","",ForumID

End Sub

Sub Forum_List_Search(ForumID)

	Selected_BySql "ForumID","SELECT ForumID,ForumName FROM Forum_Forums ORDER BY ForumID ASC","全部",ForumID

End Sub

Function today()
	wday = Weekday(Now()) 
	Select Case wday
		Case "1" wday_s = "星期日"
		Case "2" wday_s = "星期一"
		Case "3" wday_s = "星期二"
		Case "4" wday_s = "星期三"
		Case "5" wday_s = "星期四"
		Case "6" wday_s = "星期五"
		Case "7" wday_s = "星期六"
	End Select 
	today = Year(Now())&"年"&Month(Now())&"月"&day(Now())&"日"&" "&wday_s&" "
End Function 




Sub Get_Head_Navigator(str_Value)
	Script_Path = Request.ServerVariables("SCRIPT_NAME")
	Catalog_Name =  Split(Script_Path,"/")(1)

	If UCase(Catalog_Name)=UCase(str_Value) Or (UCase(Catalog_Name)="INDEX.ASP" And UCase(str_Value)="HOME") Then 
		Response.Write " class=""selected"""
	Else
		Response.Write " "
	End If 

	Exit Sub 

	If UCase(Catalog_Name) = UCase(str_Value) Or (UBound(Split(Script_Path,"/"))=1 And UCase(str_Value)="HOME") Then  
		Response.Write " class=""selected"""
	Else
		If ((UCase(Catalog_Name)="INFORMATION") Or (UCase(Catalog_Name)="TIPS") Or (UCase(Catalog_Name)="SPOT") Or (UCase(Catalog_Name)="PASSPORT") Or (UCase(Catalog_Name)="NATURE") Or (UCase(Catalog_Name)="FOOD") Or (UCase(Catalog_Name)="HISTORY") Or (UCase(Catalog_Name)="MAP") Or (UCase(Catalog_Name)="SERVICE")) And  UCase(str_Value)="HOME"  Then 
			Response.Write " class=""selected"""
		End iF
		
	End If

End Sub 
Function Show_Pic(Pic_Path)
	If Pic_Path<>"" Then 
		Pic_Path_S = Replace(Pic_Path,".","_S.")
		Show_Pic = Pic_Path_S
	Else
		Pic_Path_S = "&nbsp;"
	End If
End Function


'按格式显示日期
Function GetStrDate(dtDay,strI)
	Dim strMonth,strDay
	strMonth = Right("0"&Month(dtDay),2)
	strDay = Right("0"&Day(dtDay),2)
	GetStrDate = Year(dtDay) & strI & strMonth & strI & strDay
End Function



'设置置顶信息
'后台使用
Sub Set_Info_Top()

	If Request.ServerVariables ("Request_Method")="POST" Then

		ID_List		= reform("OP_ID")
		Sort_Type	= reform("Sort_Type")

		If ID_List="" Then 
			AlertBox "请选择要置顶的信息！","javascript:history.go(-1)"
		End If 
		
		Array_List = Split(ID_List,",")
		Conn.BeginTrans
		On Error Resume Next

		For i=0 To UBound(Array_List)
			OP_ID = Trim(Array_List(i))
			Sql = "INSERT INTO Info_Sort_Table(Info_ID,Sort_Order,Sort_Sub_ID) VALUES( "&_
				OP_ID&_
				",1000"&_
				","&Sort_Type&_
				")"
			conn.execute(Sql)
		Next 
		
		
		if err.number =0 then  
			conn.CommitTrans  
			AlertBox "设置成功！",back_url
		else 
			conn.RollbackTrans 
			AlertBox "设置失败！",back_url
		end if

	End If
End Sub 
Sub Echo(str)
	Response.Write Str
End Sub 
Function CheckNumeric(ByVal CHECK_ID)
	If CHECK_ID<>"" and IsNumeric(CHECK_ID) Then _
		CHECK_ID = cCur(CHECK_ID) _
	Else _
		CHECK_ID = 0
	CheckNumeric = CHECK_ID
End Function
Function Order_Add(Order_Type,Order_Content,Order_Price,Order_UserName,Order_Link,Order_Mobile,Order_Tel,Order_Email,Order_Remark)
	'On Error Resume Next 

	Set rsTemp = Server.CreateObject("Adodb.RecordSet")
	Set Cm=Server.CreateObject("Adodb.Command")
	Cm.CommandType=4
	Cm.ActiveConnection=conn
	Cm.CommandText="usp_Order_Insert"

	Cm.parameters(1) = Order_Type
	Cm.parameters(2) = Order_Content
	Cm.parameters(3) = Order_Price

	Cm.parameters(4) = Order_UserName

	Cm.parameters(5) = Order_Link
	Cm.parameters(6) = Order_Mobile
	Cm.parameters(7) = Order_Tel
	Cm.parameters(8) = Order_Email
	Cm.parameters(9) = Order_Remark



	rsTemp.CursorLocation=3
	rsTemp.LockType=3
	rsTemp.open cm

	Order_No  = Cm.parameters(10)' ---订单号	
	Set cm = nothing
	
	If Err.Number>0 Then 
		Order_No = ""
	End If

	Order_Add = Order_No
End Function 

%>
